home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung 2 / Power-Programmierung CD 2 (Tewi)(1994).iso / c / library / windows / winthrea / threads.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-03-22  |  8.7 KB  |  306 lines
  1. Program ThreadsTest;
  2.  
  3. {$DEFINE FASTDEMO}
  4. {^Insert a space to undefine}
  5.  
  6. {$R RESOURCE\THREADS.RES}
  7. {$C Moveable DemandLoad Discardable}
  8. {
  9. ********************************************************************
  10. *                     Threads test application                     *
  11. *                                                                  *
  12. ********************************************************************
  13. *       Copyright 1992 Robert Salesas, All Rights Reserved         *
  14. ********************************************************************
  15. *      Version: 1.00             Author:  Robert Salesas           *
  16. *      Date:    22-May-1992      Changes: Original                 *
  17. *                                                                  *
  18. ********************************************************************
  19. }
  20.  
  21.  
  22. Uses ThrdAPI,
  23.      WinDOS, WinTypes, WinProcs, Strings;
  24.  
  25.  
  26. Const
  27.   AppName = 'TPW Threads';
  28.   AppFile = 'THREADS.EXE';
  29.   ClassName = 'Threads';
  30.  
  31.  
  32. Var
  33.   Wnd : HWnd;
  34.   Msg : TMsg;
  35.  
  36.   AllDone : Boolean;
  37.  
  38.   BallProc,
  39.   LinePRoc  : TFarProc;
  40.  
  41.  
  42.  
  43. { ***** Utility functions ***** }
  44.  
  45.   Function Min(X, Y: Integer): Integer;
  46.   Begin
  47.     If (X < Y) Then
  48.       Min := X
  49.     Else
  50.       Min := Y;
  51.   End;
  52.  
  53.  
  54.   Function Max(X, Y: Integer): Integer;
  55.   Begin
  56.     If (X > Y) Then
  57.       Max := X
  58.     Else
  59.       Max := Y;
  60.   End;
  61.  
  62.  
  63.  
  64. { ***** Thread functions *****}
  65.  
  66.   Procedure LineThread(Thread : PThreadRec;  Wnd : HWnd;  wParam : Word;  lParam : LongInt);  Export;
  67.   Const
  68.     Colors : Array [0..6] Of TColorRef = ($00FF0000,
  69.                                           $0000FF00,
  70.                                           $000000FF,
  71.                                           $00FFFF00,
  72.                                           $0000FFFF,
  73.                                           $00FF00FF,
  74.                                           $00C000C0);
  75.   Var
  76.     DC   : HDC;
  77.     Rect : TRect;
  78.     Pen,
  79.     OPen : HPen;
  80.     X, Y : Integer;
  81.     Col  : TColorRef;
  82.   Begin
  83.     GetClientRect(Wnd, Rect);
  84.     X := Random(Rect.Right);
  85.     Y := Random(Rect.Bottom);
  86.     Col := Colors[Random(7)];
  87.  
  88.     Pen := CreatePen(ps_Solid, 1, Col);
  89.  
  90.     Repeat
  91.       DC := GetDC(Wnd);
  92.       If (DC = 0) Then
  93.         Begin
  94.           DeleteObject(Pen);
  95.           ExitThread;
  96.         End;
  97.  
  98.       OPen := SelectObject(DC, Pen);
  99.  
  100.       GetClientRect(Wnd, Rect);
  101.       MoveTo(DC, X, Y);
  102.       X := Max(0, Min(Rect.Right, X + Random(91) - 45));
  103.       Y := Max(0, Min(Rect.Bottom, Y + Random(91) - 45));
  104.       LineTo(DC, X, Y);
  105.  
  106.       SelectObject(DC, OPen);
  107.       ReleaseDC(Wnd, DC);
  108.     Until (YieldThread = tm_Quit);
  109.  
  110.     DeleteObject(Pen);
  111.     ExitThread;
  112.   End;
  113.  
  114.  
  115.   Procedure BallThread(Thread : PThreadRec;  Wnd : HWnd;  wParam : Word;  lParam : LongInt);  Export;
  116.   Var
  117.     DC     : HDC;
  118.     Rect   : TRect;
  119.     XDir,
  120.     YDir,
  121.     X, OX,
  122.     Y, OY  : Integer;
  123.     Ball,
  124.     Erase  : HIcon;
  125.   Begin
  126.     X := 0;
  127.     Y := 0;
  128.     XDir := 10 + (Random(11) - 5);
  129.     YDir := 10 + (Random(11) - 5);
  130.  
  131.     Ball := LoadIcon(HInstance, PChar(Random(7) + 100));
  132.     Erase := LoadIcon(HInstance, 'EraseBall');
  133.  
  134.     Repeat
  135.       DC := GetDC(Wnd);
  136.       If (DC = 0) Then
  137.         ExitThread;
  138.  
  139.       GetClientRect(Wnd, Rect);
  140.       OX := X;
  141.       OY := Y;
  142.       X := X + XDir;
  143.       Y := Y + YDir;
  144.  
  145.       If (X < 0) Then
  146.         Begin
  147.           X := 0;
  148.           XDir := -(XDir - (Random(11) - 5));
  149.           YDir := YDir + (Random(11) - 5);
  150.         End;
  151.       If (X + 32 > Rect.Right) Then
  152.         Begin
  153.           X := Rect.Right - 32;
  154.           XDir := -(XDir - (Random(11) - 5));
  155.           YDir := YDir + (Random(11) - 5);
  156.         End;
  157.  
  158.       If (Y < 0) Then
  159.         Begin
  160.           Y := 0;
  161.           XDir := XDir - (Random(11) - 5);
  162.           YDir := -(YDir + (Random(11) - 5));
  163.         End;
  164.       If (Y + 32 > Rect.Bottom) Then
  165.         Begin
  166.           Y := Rect.Bottom - 32;
  167.           XDir := XDir + (Random(11) - 5);
  168.           YDir := -(YDir + (Random(11) - 5));
  169.         End;
  170.  
  171.       If (XDir <= 0) And (XDir > -6) Then
  172.         XDir := -6;
  173.       If (XDir > 0) And (XDir < 6) Then
  174.         XDir := 6;
  175.       If (YDir <= 0) And (YDir > -6) Then
  176.         YDir := -6;
  177.       If (YDir > 0) And (YDir < 6) Then
  178.         YDir := 5;
  179.       XDir := Max(-20, Min(20, XDir));
  180.       YDir := Max(-20, Min(20, YDir));
  181.  
  182.       DrawIcon(DC, OX, OY, Erase);
  183.       DrawIcon(DC, X, Y, Ball);
  184.       ReleaseDC(Wnd, DC);
  185.     Until (YieldThread = tm_Quit);
  186.  
  187.     ExitThread;
  188.   End;
  189.  
  190.  
  191.  
  192. { ***** Window function ***** }
  193.  
  194.   Function MainWndProc(Window : HWnd;  Msg, wParam : Word;  lParam : LongInt) : LongInt;  Export;
  195.   Var
  196.     Title      : Array [0..255] Of Char;
  197.     NumThreads : LongInt;
  198.     LineThrd   : PThreadRec;
  199.   Begin
  200.     Case Msg Of
  201.       wm_Create    : Begin
  202.                        LineProc := MakeProcInstance(@LineThread, HInstance);
  203.                        BallProc := MakeProcInstance(@BallThread, HInstance);
  204.                      End;
  205.       wm_Command   : Case wParam Of
  206.                        100 : Begin
  207.                                StartThread(BallProc, 2000, Window, 30, 10);
  208.                                NumThreads := GetNumThreads;
  209.                                WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
  210.                                SetWindowText(Window, Title);
  211.                              End;
  212.                        110 : Begin
  213.                                LineThrd := StartThread(LineProc, 2000, Window, 0, 0);
  214.                                SetThreadPriority(LineThrd, ts_DefPriority Div 2);
  215.                                NumThreads := GetNumThreads;
  216.                                WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
  217.                                SetWindowText(Window, Title);
  218.                              End;
  219.  
  220.                        500 : InvalidateRect(Window, Nil,TRUE);
  221.                        510 : Begin
  222.                                EndTaskThreads(GetCurrentTask);
  223.                                InvalidateRect(Window, Nil,TRUE);
  224.                                NumThreads := GetNumThreads;
  225.                                WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
  226.                                SetWindowText(Window, Title);
  227.                              End;
  228.                      End;
  229.       wm_Destroy   : Begin
  230.                        EndTaskThreads(GetCurrentTask);
  231.                        FreeProcInstance(BallProc);
  232.                        FreeProcInstance(LineProc);
  233.  
  234.                        PostQuitMessage(0);
  235.                      End;
  236.     Else
  237.       MainWndProc := DefWindowProc(Window, Msg, wParam, lParam);
  238.     End;
  239.   End;
  240.  
  241.  
  242.  
  243. Const
  244.   WindowClass : TWndClass = (Style         : cs_HRedraw + cs_VRedraw;
  245.                              lpfnWndProc   : Nil;
  246.                              cbClsExtra    : 0;
  247.                              cbWndExtra    : 0;
  248.                              hInstance     : 0;
  249.                              hIcon         : 0;
  250.                              hCursor       : 0;
  251.                              hbrBackground : 0;
  252.                              lpszMenuName  : 'APPMENU';
  253.                              lpszClassName : ClassName);
  254.  
  255.  
  256. Begin
  257.   RandSeed := MakeLong(((GetCurrentTime SHR 16) SHL 16), ((GetCurrentTime SHR 16) SHL 16));
  258.   If (HPrevInst = 0) Then
  259.     Begin
  260.       WindowClass.lpfnWndProc   := @MainWndProc;
  261.       WindowClass.hInstance     := HInstance;
  262.       WindowClass.hIcon         := LoadIcon(HInstance, 'APPICON');
  263.       WindowClass.hCursor       := LoadCursor(0, idc_Arrow);
  264.       WindowClass.hbrBackground := GetStockObject(white_Brush);
  265.  
  266.       If Not RegisterClass(WindowClass) Then
  267.         Begin
  268.           MessageBox(0, 'Unable to register window class.', Nil, mb_Ok Or mb_IconStop);
  269.           Halt;
  270.         End;
  271.     End;
  272.  
  273.   Wnd := CreateWindow(ClassName, AppName + ' - 0 Threads', ws_OverlappedWindow,
  274.                       cw_UseDefault, 0, cw_UseDefault, 0, 0, 0, HInstance, Nil);
  275.   If (Wnd <> 0) Then
  276.     Begin
  277.       ShowWindow(Wnd, sw_ShowNormal);
  278.       UpdateWindow(Wnd);
  279.  
  280. {$IFNDEF FASTDEMO}
  281.       While GetMessage(Msg, 0, 0, 0) Do
  282.         Begin
  283.           TranslateMessage(Msg);
  284.           DispatchMessage(Msg);
  285.         End;
  286. {$ELSE}
  287.       AllDone := False;
  288.       Repeat
  289.         If PeekMessage(Msg, 0, 0, 0, pm_NoRemove) Then
  290.           Begin
  291.             If GetMessage(Msg, 0, 0, 0) Then
  292.               Begin
  293.                 TranslateMessage(Msg);
  294.                 DispatchMessage(Msg);
  295.               End
  296.             Else
  297.               AllDone := True;
  298.           End
  299.         Else
  300.           ExecTaskThreads(GetCurrentTask);
  301.       Until AllDone;
  302. {$ENDIF}
  303.     End
  304.   Else
  305.     MessageBox(0, 'Unable to open window.', Nil, mb_Ok or mb_IconStop);
  306. End.